home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xljump.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  4KB  |  170 lines
  1. /* xljump - execution context routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern CONTEXT *xlcontext,*xltarget;
  10. extern LVAL xlvalue,xlenv,xlfenv,xldenv;
  11. extern int xlmask;
  12.  
  13. /* xlbegin - beginning of an execution context */
  14. xlbegin(cptr,flags,expr)
  15.   CONTEXT *cptr; int flags; LVAL expr;
  16. {
  17.     cptr->c_flags = flags;
  18.     cptr->c_expr = expr;
  19.     cptr->c_xlstack = xlstack;
  20.     cptr->c_xlenv = xlenv;
  21.     cptr->c_xlfenv = xlfenv;
  22.     cptr->c_xldenv = xldenv;
  23.     cptr->c_xlcontext = xlcontext;
  24.     cptr->c_xlargv = xlargv;
  25.     cptr->c_xlargc = xlargc;
  26.     cptr->c_xlfp = xlfp;
  27.     cptr->c_xlsp = xlsp;
  28.     xlcontext = cptr;
  29. }
  30.  
  31. /* xlend - end of an execution context */
  32. xlend(cptr)
  33.   CONTEXT *cptr;
  34. {
  35.     xlcontext = cptr->c_xlcontext;
  36. }
  37.  
  38. /* xlgo - go to a label */
  39. xlgo(label)
  40.   LVAL label;
  41. {
  42.     CONTEXT *cptr;
  43.     LVAL *argv;
  44.     int argc;
  45.  
  46.     /* find a tagbody context */
  47.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  48.     if (cptr->c_flags & CF_GO) {
  49.         argc = cptr->c_xlargc;
  50.         argv = cptr->c_xlargv;
  51.         while (--argc >= 0)
  52.         if (*argv++ == label) {
  53.             cptr->c_xlargc = argc;
  54.             cptr->c_xlargv = argv;
  55.             xljump(cptr,CF_GO,NIL);
  56.         }
  57.     }
  58.     xlfail("no target for GO");
  59. }
  60.  
  61. /* xlreturn - return from a block */
  62. xlreturn(name,val)
  63.   LVAL name,val;
  64. {
  65.     CONTEXT *cptr;
  66.  
  67.     /* find a block context */
  68.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  69.     if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
  70.         xljump(cptr,CF_RETURN,val);
  71.     xlfail("no target for RETURN");
  72. }
  73.  
  74. /* xlthrow - throw to a catch */
  75. xlthrow(tag,val)
  76.   LVAL tag,val;
  77. {
  78.     CONTEXT *cptr;
  79.  
  80.     /* find a catch context */
  81.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  82.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  83.         xljump(cptr,CF_THROW,val);
  84.     xlfail("no target for THROW");
  85. }
  86.  
  87. /* xlsignal - signal an error */
  88. xlsignal(emsg,arg)
  89.   char *emsg; LVAL arg;
  90. {
  91.     CONTEXT *cptr;
  92.  
  93.     /* find an error catcher */
  94.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  95.     if (cptr->c_flags & CF_ERROR) {
  96.         if (cptr->c_expr && emsg)
  97.         xlerrprint("error",NULL,emsg,arg);
  98.         xljump(cptr,CF_ERROR,NIL);
  99.     }
  100. }
  101.  
  102. /* xltoplevel - go back to the top level */
  103. xltoplevel()
  104. {
  105.     stdputstr("[ back to top level ]\n");
  106.     findandjump(CF_TOPLEVEL,"no top level");
  107. }
  108.  
  109. /* xlbrklevel - go back to the previous break level */
  110. xlbrklevel()
  111. {
  112.     findandjump(CF_BRKLEVEL,"no previous break level");
  113. }
  114.  
  115. /* xlcleanup - clean-up after an error */
  116. xlcleanup()
  117. {
  118.     stdputstr("[ back to previous break level ]\n");
  119.     findandjump(CF_CLEANUP,"not in a break loop");
  120. }
  121.  
  122. /* xlcontinue - continue from an error */
  123. xlcontinue()
  124. {
  125.     findandjump(CF_CONTINUE,"not in a break loop");
  126. }
  127.  
  128. /* xljump - jump to a saved execution context */
  129. xljump(target,mask,val)
  130.   CONTEXT *target; int mask; LVAL val;
  131. {
  132.     /* unwind the execution stack */
  133.     for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
  134.  
  135.     /* check for an UNWIND-PROTECT */
  136.     if ((xlcontext->c_flags & CF_UNWIND)) {
  137.         xltarget = target;
  138.         xlmask = mask;
  139.         break;
  140.     }
  141.        
  142.     /* restore the state */
  143.     xlstack = xlcontext->c_xlstack;
  144.     xlenv = xlcontext->c_xlenv;
  145.     xlfenv = xlcontext->c_xlfenv;
  146.     xlunbind(xlcontext->c_xldenv);
  147.     xlargv = xlcontext->c_xlargv;
  148.     xlargc = xlcontext->c_xlargc;
  149.     xlfp = xlcontext->c_xlfp;
  150.     xlsp = xlcontext->c_xlsp;
  151.     xlvalue = val;
  152.  
  153.     /* call the handler */
  154.     longjmp(xlcontext->c_jmpbuf,mask);
  155. }
  156.  
  157. /* findandjump - find a target context frame and jump to it */
  158. LOCAL findandjump(mask,error)
  159.   int mask; char *error;
  160. {
  161.     CONTEXT *cptr;
  162.  
  163.     /* find a block context */
  164.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  165.     if (cptr->c_flags & mask)
  166.         xljump(cptr,mask,NIL);
  167.     xlabort(error);
  168. }
  169.  
  170.